home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / 1svga.zip / BLOCK.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-07  |  7KB  |  226 lines
  1. {┌────────────────────────────────────┐
  2.  │ Tetris(Block) V1.1                 │
  3.  │ Written by Jou-Nan Chen 1994       │
  4.  └────────────────────────────────────┘}
  5.  
  6. uses Crt,SVGA256,Txt;
  7.  
  8. const
  9.   Xi=116; Yi=16;
  10.   C:byte=37; C2:byte=35;  C3:byte=0;    { Window,GameOver,Box }
  11.   Data:array[0..27,0..7] of shortint=(  { ■ ── Z S ┴ ─┘ └─ }
  12.     (0,0,1,0,0,1,1,1),   (0,0,1,0,0,1,1,1),  (0,0,1,0,0,1,1,1),
  13.     (0,0,1,0,0,1,1,1),   (-2,0,-1,0,0,0,1,0),(0,-1,0,0,0,1,0,2),
  14.     (-2,0,-1,0,0,0,1,0), (0,-1,0,0,0,1,0,2), (-1,0,0,0,0,1,1,1),
  15.     (1,-1,0,0,1,0,0,1),  (-1,0,0,0,0,1,1,1), (1,-1,0,0,1,0,0,1),
  16.     (0,0,1,0,-1,1,0,1),  (0,-1,0,0,1,0,1,1), (0,0,1,0,-1,1,0,1),
  17.     (0,-1,0,0,1,0,1,1),  (0,-1,-1,0,0,0,1,0),(0,-1,-1,0,0,0,0,1),
  18.     (-1,0,0,0,1,0,0,1),  (0,-1,0,0,1,0,0,1), (1,-1,-1,0,0,0,1,0),
  19.     (-1,-1,0,-1,0,0,0,1),(-1,0,0,0,1,0,-1,1),(0,-1,0,0,0,1,1,1),
  20.     (-1,-1,-1,0,0,0,1,0),(0,-1,0,0,-1,1,0,1),(-1,0,0,0,1,0,1,1),
  21.     (0,-1,1,-1,0,0,0,1));
  22. var Pic:array[0..447] of byte;
  23.     PicBack:array[0..7999] of byte;
  24.     Font1:array[0..767] of byte;
  25.     B:array[0..19,0..9] of byte;
  26.     No,X,Y,OldX,OldY,OldNo,Drop,Delay1:integer;
  27.     Level,Score,Lines,OldLines:longint;
  28.     Ch:char;
  29.  
  30. { ─────────────── Sounds ─────────────── }
  31. procedure Sounds(No:byte);
  32. var I:integer;
  33. begin
  34.   case No of
  35.     1:for I:=1 to 20 do begin Sound(5*Random(500)+900); Delay(1); end;
  36.     2:begin
  37.     Sound(800); Delay(90);
  38.     Sound(600); Delay(90);
  39.     Sound(400); Delay(90);
  40.       end;
  41.     3:for I:=1 to 10 do begin Sound(50*Random(100)+500); Delay(50); end;
  42.   end;
  43.   NoSound;
  44. end;
  45. { ─────────────── Screen ─────────────── }
  46. procedure Screen(X,Y:integer);  { 88x168 }
  47. var I:integer;
  48. begin
  49.   for I:=0 to 7 do Put(80*(I mod 4),100*(I div 4),80,100,PicBack);
  50.   for I:=0 to 3 do Box(X+I,Y+I,88-2*I,168-2*I,64+I);
  51.   Bar(X+4,Y+4,80,160,0);
  52.   Bar(36,16,72,76,C);  Box(38,18,68,72,C3);
  53.   Bar(212,16,52,42,C); Box(214,18,48,38,C3);
  54.   Print(44,24,14,'Level'); Print(92,34,14,'0');
  55.   Print(44,44,14,'Score'); Print(92,54,14,'0');
  56.   Print(44,64,14,'Line');  Print(92,74,14,'0');
  57. end;
  58. { ─────────────── PutBlock ─────────────── }
  59. procedure PutBlock(X,Y,No:integer);
  60. var I,Xp,Yp:integer;
  61. begin
  62.   for I:=0 to 3 do begin
  63.     Xp:=8*Data[No,2*I]+X; Yp:=8*Data[No,2*I+1]+Y;
  64.     Put(Xp,Yp,8,8,Pic[64*(No div 4)]);
  65.   end;
  66. end;
  67. { ─────────────── EraseBlock ─────────────── }
  68. procedure EraseBlock(X,Y,No:integer);
  69. var I,Xp,Yp:integer;
  70. begin
  71.   for I:=0 to 3 do begin
  72.     Xp:=8*Data[No,2*I]+X; Yp:=8*Data[No,2*I+1]+Y;
  73.     Bar(Xp,Yp,8,8,0);
  74.   end;
  75. end;
  76. { ─────────────── Keys ─────────────── }
  77. procedure Keys;
  78. var I:integer;
  79.     St:string[7];
  80. begin
  81. if KeyPressed=1 then begin
  82.   Ch:=ReadKey;
  83.   case Ch of
  84.     '4':begin
  85.           X:=X-1;
  86.           for I:=0 to 3 do if (Data[No,2*I]+X<0) or
  87.             (B[Data[No,2*I+1]+Y,Data[No,2*I]+X]=1) then X:=X+1;
  88.         end;
  89.     '6':begin
  90.       X:=X+1;
  91.       for I:=0 to 3 do if (Data[No,2*I]+X>9) or
  92.         (B[Data[No,2*I+1]+Y,Data[No,2*I]+X]=1) then X:=X-1;
  93.         end;
  94.     '5':begin
  95.           No:=No+1; if No mod 4=0 then No:=No-4;
  96.       for I:=0 to 3 do if (Data[No,2*I]+X<0) or (Data[No,2*I]+X>9)
  97.             or (Data[No,2*I+1]+Y<0) or (Data[No,2*I+1]+Y>19) or
  98.             (B[Data[No,2*I+1]+Y,Data[No,2*I]+X]=1) then
  99.               if No mod 4=0 then No:=No+3 else No:=No-1;
  100.         end;
  101.     '2':Delay1:=0;
  102.     '~':begin
  103.       Level:=Level+1; Str(Level:7,St);
  104.       Bar(44,34,60,8,C); Print(44,34,14,St);
  105.           Delay1:=32-3*(Level mod 10);
  106.         end;
  107.   end;
  108.   EraseBlock(Xi+4+8*OldX,Yi+4+8*OldY,OldNo);
  109.   PutBlock(Xi+4+8*X,Yi+4+8*Y,No);
  110.   OldX:=X; OldY:=Y; OldNo:=No;
  111. end;
  112. end;
  113. { ─────────────── EraseLines ─────────────── }
  114. procedure EraseLines;
  115. var N:array[1..4] of byte;
  116.     Ok,M,I,J,Num:integer;
  117.     St:string[7];
  118. begin
  119.   Num:=0;
  120.   for J:=0 to 19 do begin
  121.     Ok:=0; for I:=0 to 9 do if B[J,I]=0 then Ok:=1;
  122.     if Ok=0 then begin Num:=Num+1; N[Num]:=J; end;
  123.   end;
  124.   for J:=1 to Num do begin
  125.     for I:=N[J]*8+7 downto 8 do begin
  126.       M:=320*(Yi+I+4)+Xi+4;
  127.       Move(Mem[$A000:M-2560],Mem[$A000:M],80);
  128.     end;
  129.     for I:=N[J] downto 1 do Move(B[I-1],B[I],10);
  130.   end;
  131.   if Num>0 then begin
  132.     Lines:=Lines+Num; Str(Lines:7,St);
  133.     Bar(44,74,60,8,C); Print(44,74,14,St);
  134.     Sounds(2);
  135.     if Lines>10*(OldLines div 10)+9 then begin
  136.       Level:=Level+1; Str(Level:7,St);
  137.       Bar(44,34,60,8,C); Print(44,34,14,St);
  138.       Sounds(3); OldLines:=Lines;
  139.     end;
  140.   end;
  141. end;
  142. { ─────────────── GameOver ─────────────── }
  143. procedure GameOver(X,Y:integer);  { 140x70 }
  144. begin
  145.   Bar(X,Y,140,70,C2);
  146.   Box(X+2,Y+2,136,66,C3); Line(X+3,Y+22,X+136,Y+22,C3);
  147.   Print(X+32,Y+ 8,14,'Game Over');
  148.   Print(X+12,Y+32,14,'Esc-Quit game');
  149.   Print(X+12,Y+48,14,'Enter-Continue');
  150.   repeat
  151.     Ch:=ReadKey;
  152.     if Ch=#27 then begin
  153.       TextMode(LastMode); Mem[0:$417]:=Mem[0:$417] and $DF;
  154.       Halt(1);
  155.     end;
  156.   until Ch in [#13,#27];
  157. end;
  158. { ─────────────── Title ─────────────── }
  159. procedure Title;
  160. const
  161.   St:array[0..9] of string[25]=(
  162.     '           2222          ',
  163.     '0000      2    2    4   4',
  164.     '0   0 1   2    2    4  4 ',
  165.     '0   0 1   2   3333  4 4  ',
  166.     '0000  1   2  3 2  3 44   ',
  167.     '0   0 1   2  3 2    4 4  ',
  168.     '0   0 1    2232     4  4 ',
  169.     '0000  1      3      4   4',
  170.     '      11111  3    3      ',
  171.     '              3333       ');
  172. var I,J,N:integer;
  173. begin
  174.   SetMode(1); Bar(0,0,320,200,104);
  175.   for J:=0 to 9 do for I:=0 to 24 do begin
  176.     N:=(Ord(St[J][I+1])-48)*7 div 5;
  177.     if N>=0 then Put(50+8*I,30+8*J,8,8,Pic[64*N]);
  178.   end;
  179.   Print2(40,135,64,'A game comes from "TETRIS"');
  180.   Print2(40,155,64,'"BLOCK" Version 1.1');
  181.   Print2(40,165,64,'Written by Jou-Nan Chen 1994');
  182.   Ch:=ReadKey; Ch:=#0;
  183. end;
  184.  
  185. { ████▓▓▓▓▒▒▒▒░░░░ Main Program ░░░░▒▒▒▒▓▓▓████ }
  186.  
  187. label 1000;
  188. var I,Ok,No1,No2:integer;
  189.     St:string[7];
  190. begin
  191.   FileRead('block.dat',0,7,64,Pic);
  192.   FileRead('block.pic',0,1,8000,PicBack);
  193.   FileRead('0808art.fnt',0,96,8,Font1);
  194.   InstallFont(1,8,8,32,96,8,Font1);
  195.   1000: Title;
  196.   Level:=0; Score:=0; Lines:=0; OldLines:=0;
  197.   Randomize; Screen(Xi,Yi); Ch:=#0; Drop:=0; Ok:=0;
  198.   for Y:=0 to 19 do for X:=0 to 9 do B[Y,X]:=0;
  199.   No1:=4*Random(7);
  200.   repeat
  201.     X:=4; Y:=1; OldX:=4; OldY:=1; Delay1:=32-3*(Level mod 10);
  202.     No2:=4*Random(7); Bar(216,20,44,34,C); PutBlock(236,34,No2);
  203.     No:=No1; OldNo:=No; PutBlock(Xi+4+8*X,Yi+4+8*Y,No); No1:=No2;
  204.     repeat
  205.       Mem[0:$417]:=Mem[0:$417] or $20; Keys;
  206.       Delay(Delay1); Drop:=Drop+1;
  207.       if Drop>20 then begin
  208.     Drop:=0; Y:=Y+1;
  209.     Ok:=0;
  210.     for I:=0 to 3 do if (Data[No,2*I+1]+Y>19)
  211.       or (B[Data[No,2*I+1]+Y,Data[No,2*I]+X]=1) then
  212.       begin Y:=Y-1; Ok:=1; end;
  213.     EraseBlock(Xi+4+8*OldX,Yi+4+8*OldY,OldNo);
  214.     PutBlock(Xi+4+8*X,Yi+4+8*Y,No);
  215.     OldX:=X; OldY:=Y; OldNo:=No;
  216.       end;
  217.     until (Ok=1) or (Ch=#27);
  218.     Score:=Score+15+5*(Level mod 10); Str(Score:7,St);
  219.     Bar(44,54,60,8,C); Print(44,54,14,St);
  220.     for I:=0 to 3 do B[Data[No,2*I+1]+Y,Data[No,2*I]+X]:=1;
  221.     Ok:=0; for I:=0 to 3 do if Data[No,2*I+1]+Y=1 then Ok:=1;
  222.     Sounds(1); EraseLines;
  223.   until (Ok=1) or (Ch=#27);
  224.   GameOver(90,65); goto 1000;
  225. end.
  226.